(define (uarta:analyze-argument-types prog)
  (define types #f)
  (define types-modified? #f)
  (define (initial-types)
    `(,(initial-types-func 'any (car prog))
      unquote
      (map (lambda (fundef) (initial-types-func 'absent fundef)) (cdr prog))))
  (define (initial-types-func pars-type fundef)
    (let ((parlist (cadr fundef)) (fname (car fundef)))
      `(,fname unquote (map (lambda (par) pars-type) parlist))))
  (define (collect-args-prog!)
    (for-each
      (lambda (fundef)
        (let ((body (cadddr fundef))
              (parlist (cadr fundef))
              (fname (car fundef)))
          (let ((%%88 (assq fname types)))
            (let ((fargs (cdr %%88))) (collect-args! body parlist fargs)))))
      prog))
  (define (collect-args! exp vn vv)
    (cond ((symbol? exp) #f)
          ((equal? (car exp) 'quote) #f)
          ((equal? (car exp) 'call)
           (let ((exp* (cddr exp)) (fname (cadr exp)))
             (collect-args*! exp* vn vv)
             (update-args! fname (t-eval* exp* vn vv))))
          ((equal? (car exp) 'xcall)
           (let ((exp* (cddr exp)) (fname (cadr exp)))
             (collect-args*! exp* vn vv)))
          (else
           (let ((exp* (cdr exp)) (op (car exp)))
             (collect-args*! exp* vn vv)))))
  (define (collect-args*! exp* vn vv)
    (for-each (lambda (exp) (collect-args! exp vn vv)) exp*))
  (define (t-eval exp vn vv)
    (cond ((symbol? exp) (lookup-variable exp vn vv))
          ((equal? (car exp) 'quote) (let ((c (cadr exp))) (t-eval-const c)))
          ((equal? (car exp) 'car)
           (let ((exp1 (cadr exp))) (t-eval-car (t-eval exp1 vn vv))))
          ((equal? (car exp) 'cdr)
           (let ((exp1 (cadr exp))) (t-eval-cdr (t-eval exp1 vn vv))))
          ((equal? (car exp) 'pair?)
           (let ((exp1 (cadr exp))) (t-eval-pair? (t-eval exp1 vn vv))))
          ((equal? (car exp) 'cons)
           (let ((exp2 (caddr exp)) (exp1 (cadr exp)))
             (t-eval-cons (t-eval exp1 vn vv) (t-eval exp2 vn vv))))
          (else 'any)))
  (define (t-eval* exp* vn vv) (map (lambda (exp) (t-eval exp vn vv)) exp*))
  (define (t-eval-const c)
    (if (not (pair? c))
      `(atom ,c)
      (let ((c2 (cdr c)) (c1 (car c)))
        `(cons ,(t-eval-const c1) ,(t-eval-const c2)))))
  (define (t-eval-car t0)
    (cond ((equal? t0 'absent) 'absent)
          ((equal? t0 'any) 'any)
          ((equal? (car t0) 'atom) 'absent)
          ((equal? (car t0) 'cons) (let ((t2 (caddr t0)) (t1 (cadr t0))) t1))
          (else (error "SELECT: no match for" t0))))
  (define (t-eval-cdr t0)
    (cond ((equal? t0 'absent) 'absent)
          ((equal? t0 'any) 'any)
          ((equal? (car t0) 'atom) 'absent)
          ((equal? (car t0) 'cons) (let ((t2 (caddr t0)) (t1 (cadr t0))) t2))
          (else (error "SELECT: no match for" t0))))
  (define (t-eval-cons t1 t2)
    (cond ((equal? t1 'absent) 'absent)
          ((equal? t2 'absent) 'absent)
          (else `(cons ,t1 ,t2))))
  (define (t-eval-pair? t0)
    (cond ((equal? t0 'absent) 'absent)
          ((equal? t0 'any) 'any)
          ((equal? (car t0) 'atom) '(atom #f))
          ((equal? (car t0) 'cons)
           (let ((t2 (caddr t0)) (t1 (cadr t0))) '(atom #t)))
          (else (error "SELECT: no match for" t0))))
  (define (lub t1 t2)
    (cond ((equal? t1 t2) t1)
          ((equal? t1 'absent) t2)
          ((equal? t2 'absent) t1)
          ((equal? t1 'any) 'any)
          ((equal? t2 'any) 'any)
          ((equal? (car t1) 'atom) (let ((a (cadr t1))) 'any))
          ((equal? (car t2) 'atom) (let ((b (cadr t2))) 'any))
          ((and (equal? (car t1) 'cons) (equal? (car t2) 'cons))
           (let ((v2 (caddr t2)) (v1 (cadr t2)) (u2 (caddr t1)) (u1 (cadr t1)))
             `(cons ,(lub u1 v1) ,(lub u2 v2))))
          (else (error "SELECT: no match for" t1 t2))))
  (define (lub* t1* t2*) (map lub t1* t2*))
  (define (update-args! fname args)
    (let ((%%89 (assq fname types)))
      (let ((fdescr %%89))
        (let ((args1 (cdr fdescr)))
          (let ((%%90 (lub* args args1)))
            (let ((lub-args %%90))
              (if (not (equal? lub-args args1))
                (begin
                  (set-cdr! fdescr lub-args)
                  (set! types-modified? #t)))))))))
  (define (lookup-variable vname vn vv)
    (if (and (null? vn) (null? vv))
      (error "Undefined variable" vname)
      (let ((vrest (cdr vv)) (vv (car vv)) (nrest (cdr vn)) (vn (car vn)))
        (if (eq? vname vn) vv (lookup-variable vname nrest vrest)))))
  (set! types (initial-types))
  (let recalc-types! ()
    (display "*")
    (set! types-modified? #f)
    (collect-args-prog!)
    (if types-modified? (recalc-types!) types)))

